{- 

    Copyright © 2011 - 2016, Ingo Wechsung
    All rights reserved.

    Redistribution and use in source and binary forms, with or
    without modification, are permitted provided that the following
    conditions are met:

        Redistributions of source code must retain the above copyright
        notice, this list of conditions and the following disclaimer.

        Redistributions in binary form must reproduce the above
        copyright notice, this list of conditions and the following
        disclaimer in the documentation and/or other materials provided
        with the distribution. Neither the name of the copyright holder
        nor the names of its contributors may be used to endorse or
        promote products derived from this software without specific
        prior written permission.

    THIS SOFTWARE IS PROVIDED BY THE
    COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
    IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER
    OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
    USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
    AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
    IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
    THE POSSIBILITY OF SUCH DAMAGE.

     -}

--- nice printing of several compiler stuff

package frege.compiler.classes.Nice
 
    where


import Data.TreeMap as TM(TreeMap, each)
import Lib.PP(DOCUMENT,text)

import  frege.compiler.types.NSNames
import  frege.compiler.types.SNames
import  frege.compiler.types.Packs
import  frege.compiler.types.QNames
import  frege.compiler.types.Symbols
import  frege.compiler.types.Types(SigmaT, RhoT)
import  frege.compiler.types.Global

--- things that need the environment to print nicely
class Nice a where
    nice :: a -> Global -> String
    nicer :: a -> Global -> String
    nicest :: Global -> a -> DOCUMENT
    nicet :: Global -> a -> DOCUMENT
    nicer a g = nice a g
    nicest g a = text (nicer a g)
    --- use 'nicer' to create a 'DOCUMENT'
    nicet g x = text (nicer x g)

instance Nice String where
    nice s _ = s


instance Nice QName where
    nice    (TName p s)  g
        | inPrelude p g  = s
        | p == (Global.thisPack g) = s
        | otherwise = p.nice g ++ "." ++ s
    nice    (VName p s)  g
        | inPrelude p g  = s
        | p == (Global.thisPack g) = s
        | otherwise = p.nice g ++ "." ++ s
    nice    (MName t s)    g = t.nice g ++ "." ++ s
    nice    (Local {uid, base}) g = base ++ "{" ++ show uid ++ "}"
    --- 'nicer' gives a short form of a 'TName' if it can be found locally
    nicer (Local {uid, base}) g = base
    nicer (qn@TName p s) g
        | Global.findit g qn == Global.findit g (TName g.thisPack s) = s
    nicer    (MName t s)    g = t.nicer g ++ "." ++ s
    nicer  qn g = nice qn g


instance Nice SName where
    nice s _ = s.show


instance Nice Symbol where
    nice (sym@SymL {alias}) g = category sym g ++ " `" ++ alias.nice g ++ "`"
    nice sym g = category sym g ++ " `" ++ sym.name.nice g ++ "`"
    nicer (sym@SymL {alias}) g = category sym g ++ " `" ++ alias.nicer g ++ "`"
    nicer sym g = category sym g ++ " `" ++ sym.name.nicer g ++ "`"


protected category (SymT {name}) g = "data type"
protected category (SymD {name}) g = "constructor"
protected category (SymC {name}) g = "class"
protected category (SymI {name}) g = "instance"
protected category (symv@SymV {name,nativ, expr}) g = if isJust nativ then "native " ++ fun else fun
    where fun | MName t b <- name, Just sym <- Global.find g t
                                  = category sym g ++ " member " ++ funval
              | MName _ _ <- name = "member " ++ funval
              | otherwise         = funval
          funval | isJust nativ = "function"
                 | ForAll _ RhoFun{} <- symv.typ = "function"
                 | otherwise = "value"
protected category (SymA {name}) g = "type alias"
protected category (SymL {alias}) g = case g.find alias of
    Just sym -> "alias for " ++ category sym g
    Nothing  -> "alias"



instance Nice Pack where
    nice p g
        -- p == pPrelude   = "Prelude"
        | p == Global.thisPack g = ""
        | otherwise = case filter ((p==) • snd) (each (Global.namespaces g)) of
                ((NSX s, _):_) -> s
                _              -> p.nsName.unNS


